home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / wcl-21.lha / wcl-2.1 / src / compiler / cross / macros.lisp < prev   
Lisp/Scheme  |  1992-09-10  |  11KB  |  374 lines
  1. ;;; (C) Copyright 1990-1992 by Wade L. Hennessey. All rights reserved.
  2.  
  3. (in-package "W")
  4.  
  5. (defmacro letf ((accessor-form new-value) &body body)
  6.   (let ((old-value (gensym "OLD-VALUE-")))
  7.     `(let ((,old-value ,accessor-form))
  8.       (unwind-protect (progn (setf ,accessor-form ,new-value)
  9.                  ,@body)
  10.     (setf ,accessor-form ,old-value)))))
  11.  
  12. (defmacro iterate (name var-vals &body body)
  13.   `(labels ((,name ,(mapcar #'first var-vals)
  14.          ,@body))
  15.     (,name ,@(mapcar #'second var-vals))))
  16.  
  17. (defmacro key-list-iterate (name (ivar list-form &optional done-form)
  18.                  var-init-pairs
  19.                  &body body)
  20.   (let ((iteration-label
  21.      (gensym (concatenate 'string (symbol-name name) "-")))
  22.     (remaining-list (gensym "REMAINING-LIST-"))
  23.     (vars (mapcar #'first var-init-pairs))
  24.     (vals (mapcar #'second var-init-pairs)))
  25.     `(macrolet ((,name (&key ,@(mapcar #'(lambda (var)
  26.                        `(,var ',var))
  27.                        vars))
  28.          (list ',iteration-label
  29.                (list 'cdr ',remaining-list)
  30.                ,@vars)))
  31.       (labels ((,iteration-label ,(cons remaining-list vars)
  32.          (if (null ,remaining-list)
  33.              ,done-form
  34.              (let ((,ivar (car ,remaining-list)))
  35.                ,@body))))
  36.     (,iteration-label ,list-form ,@vals)))))
  37.  
  38. ;;; Each name should be an object which may be coerced into
  39. ;;; a string. Return a symbol whose print-name is the concatenation
  40. ;;; of those strings.
  41. (defun names->symbol (&rest names)
  42.   (intern (apply #'concatenate
  43.                  'string
  44.                  (mapcar #'string names))))
  45.  
  46. (defun tree-find (e tree)
  47.   (labels ((loopy (rest)
  48.          (if (atom rest)
  49.          (if (null rest)
  50.              nil
  51.              (eq e rest))
  52.          (or (loopy (car rest)) (loopy (cdr rest))))))
  53.     (loopy tree)))
  54.  
  55. (defun upto (e l)
  56.   (nreverse (cdr (member e (reverse l)))))
  57.  
  58. ;;; Return real body and decls
  59. (defun parse-body (body)
  60.   (iterate separate ((rest (if (stringp (car body)) ; discard doc string
  61.                    (if (null (cdr body))
  62.                    body
  63.                    (cdr body))
  64.                    body))
  65.              (decls nil))
  66.        (let ((form (car rest)))
  67.          (if (or (atom form)
  68.              (not (eq (car form) 'declare)))
  69.          (values rest        ; real body
  70.              decls)
  71.          (separate (cdr rest) (append (cdr form) decls))))))
  72.  
  73. ;;; Call INIT-FUNC N times, returing the results in a list.
  74. (defun n-list (n init-func)
  75.   (if (= n 0)
  76.       nil
  77.       (cons (funcall init-func) (n-list (1- n) init-func))))
  78.  
  79. ;;; Return every Nth element of L (for N >= 1). The odd
  80. ;;; part is that we always start with the first element.
  81. (defun every-n (n l)
  82.   (iterate doit ((i 1)
  83.          (rest l))
  84.        (cond ((null rest) nil)
  85.          ((= i 1) (cons (car rest) (doit n (cdr rest))))
  86.          (t (doit (1- i) (cdr rest))))))
  87.  
  88. (defun every-even (l)
  89.   (every-n 2 l))
  90.  
  91. (defun every-odd (l)
  92.   (every-n 2 (cdr l)))
  93.  
  94. (defun walk (func l)
  95.   (if (atom l)
  96.       (if (null l)
  97.       nil
  98.       (funcall func l))
  99.       (or (walk func (car l)) (walk func (cdr l)))))
  100.  
  101. (defun combos (objs)
  102.   (iterate loopy ((rest objs)
  103.           (combo nil))
  104.        (if (null rest)
  105.            (list (reverse combo))
  106.            (loop for x in (car rest)
  107.              nconcing (loopy (cdr rest) (cons x combo))))))
  108.  
  109. ;;; INCREDIBLE! Common Lisp doesn't provide a standard function
  110. ;;; for printing the time of day out to a stream!
  111. ;;; I'm suprised there isn't a format directive to do this...
  112. (defun print-time (&key (stream t) (universal-time (get-universal-time))
  113.             24-hour-time)
  114.   (multiple-value-bind (seconds
  115.             minutes
  116.             hours
  117.             day
  118.             month
  119.             year
  120.             day-of-week
  121.             daylight-savings
  122.             time-zone)
  123.       (decode-universal-time universal-time)
  124.     (declare (ignore daylight-savings time-zone))
  125.     (let ((am? (< hours 12)))
  126.       (format stream "~A:~2,'0D:~2,'0D ~Aon ~A, ~A ~A, ~A"
  127.           (if 24-hour-time
  128.           hours
  129.           (let ((h (if am? hours (- hours 12))))
  130.             (if (= h 0) 12 h)))
  131.           minutes
  132.           seconds
  133.           (if 24-hour-time
  134.           ""
  135.           (if am? "am " "pm "))
  136.           (svref #("Monday" "Tuesday" "Wednesday" "Thursday"
  137.                "Friday" "Saturday" "Sunday")
  138.              day-of-week)
  139.           (svref #("January" "February" "March" "April" "May"
  140.                "June" "July" "August" "September" "October"
  141.                "November" "December")
  142.              (1- month))
  143.           day
  144.           year))))
  145.  
  146. ;;; This should probably be inline.
  147. (defun collect (func args)
  148.   (do ((rest (cdr args) (cdr rest))
  149.        (result (car args) (funcall func result (car rest))))
  150.       ((null rest) result)))
  151.  
  152. (defun same-length-p (l1 l2)
  153.   (if (eq l1 '())
  154.       (eq l2 '())
  155.       (if (eq l2 '())
  156.       nil
  157.       (same-length-p (cdr l1) (cdr l2)))))
  158.  
  159. ;;; CL macro defining stuff
  160.  
  161. (defvar *macro-expanders* (make-hash-table :test #'eq))
  162.  
  163. (defvar *compiler-macro-expanders* (make-hash-table :test #'eq))
  164.  
  165. (defvar *type-macro-expanders* (make-hash-table))
  166.  
  167. (defvar *macroexpand-hook-w* #'funcall
  168.   "Function used to invoke macro expansion functions")
  169.  
  170. (defstruct macro-env
  171.   macros
  172.   symbol-macros)
  173.  
  174. (defstruct basic-macro
  175.   original-arg-list
  176.   expansion-function)
  177.  
  178. (defstruct (macro (:include basic-macro)))
  179.  
  180. (defstruct (compiler-macro (:include basic-macro)))
  181.  
  182. (defstruct (type-macro (:include basic-macro)))
  183.  
  184. (defmacro defmacro-w (name lambda-list &body body)
  185.   `(define-macro ',name
  186.     ,(parse-macro-definition name lambda-list nil body)))
  187.  
  188. (defmacro deftype-w (name lambda-list &body body)
  189.   `(define-type
  190.     ',name
  191.     ,(parse-macro-definition name lambda-list '* body)))
  192.  
  193. (defmacro define-compiler-macro-w (name lambda-list &body body)
  194.   `(define-compiler-macro-1 ',name
  195.     ,(parse-macro-definition name lambda-list nil body)))
  196.  
  197. (load "../cl/functions/cross-macros.lisp")
  198.  
  199. ;;; ADD - make &body (body decls) destructure with PARSE-BODY
  200. (defun parse-macro-definition (name args optional-default body)
  201.   (let ((args-without-&body (subst '&rest '&body args)))
  202.     (multiple-value-bind (whole-arg args-without-whole)
  203.     (if (eq (car args-without-&body) '&whole)
  204.         (values (second args-without-&body) (cddr args-without-&body))
  205.         (values (gensym "WHOLE") args-without-&body))
  206.       (multiple-value-bind (env-arg args-without-macro-stuff)
  207.       (let ((env (member '&environment args-without-whole :test #'eq)))
  208.         (if (null env) 
  209.         (values (gensym "ENV") args-without-whole)
  210.         (values (second env)
  211.             (append (upto '&environment args-without-whole)
  212.                 (cddr env)))))
  213.     (let ((dbind-list  (if (null optional-default)
  214.                   args-without-macro-stuff
  215.                   (insert-optional-default
  216.                    args-without-macro-stuff
  217.                    `(quote ,optional-default)))))
  218.       `(function (lambda (,whole-arg ,env-arg)
  219.          (declare (ignoreable ,env-arg))
  220.          (block ,name
  221.            (destructuring-bind ,@(if (null dbind-list)
  222.                      '(nil nil)
  223.                     `(,dbind-list (cdr ,whole-arg)))
  224.              (block ,name 
  225.                ,@body))))))))))
  226.  
  227. ;;; TODO: Make it do nice error checking and reporting? Use
  228. ;;;       it to replace the pattern matcher in some cases?
  229. ;;; DO NOT USE THIS???
  230. ;;; The expansion could be made more efficient (fewer cars/cdrs)
  231. ;;; if we factor out common subexpressions.
  232. (defmacro destructure ((vars form) &body body)
  233.   (labels ((walk-vars (expr path)
  234.          (if (atom expr)
  235.          (if (null expr)
  236.              expr
  237.              `((,expr ,path)))
  238.          (append (walk-vars (car expr) `(car ,path))
  239.              (walk-vars (cdr expr) `(cdr ,path))))))
  240.     (let ((f (gensym "FORM-")))
  241.       `(let ((,f ,form))
  242.     (let ,(walk-vars vars f) ,@body)))))
  243.  
  244.  
  245. ;;; HEY! I think key's should get the same treatment, but the
  246. ;;; manual doesn't think to say so....
  247. (defun insert-optional-default (lambda-list default)
  248.   (loop for x in lambda-list
  249.     for optional? =  (or (and optional?
  250.                   (not (member x lambda-list-keywords
  251.                            :test #'eq)))
  252.                  (eq x  '&optional))
  253.     collect (if (and (not (eq x '&optional))  optional?)
  254.             (typecase x
  255.               (symbol `(,x ,default))
  256.               (list `(,(first x) ,default  ,@(cddr x))))
  257.             x)))
  258.  
  259. (defun macro-function-w (symbol)
  260.   (let ((expander (lookup-macro-expander symbol *macro-expanders* nil)))
  261.     (if (null expander)
  262.     nil
  263.     (basic-macro-expansion-function expander))))
  264.  
  265. (defun compiler-macro-function-w (name &optional env)
  266.   (declare (ignore env))
  267.   (gethash name *compiler-macro-expanders*))
  268.  
  269. (defun macro-arg-list (symbol table)
  270.   (let ((expander (lookup-macro-expander symbol table nil)))
  271.     (if (null expander)
  272.     nil
  273.     (basic-macro-original-arg-list expander))))
  274.  
  275. (defun define-macro-function (symbol function arg-list table constructor)
  276.   (setf (gethash symbol table)
  277.     (funcall constructor
  278.          :expansion-function function
  279.          :original-arg-list arg-list))
  280.   symbol)
  281.  
  282. (defun macroexpand-w (form &optional local-macro-env)
  283.   (expand-macro form *macro-expanders* local-macro-env t nil))
  284.  
  285. (defun macroexpand-1-w (form &optional local-macro-env)
  286.   (expand-macro form *macro-expanders* local-macro-env nil nil))
  287.  
  288. (defun compiler-macroexpand-w (form &optional local-macro-env)
  289.   (expand-macro form *compiler-macro-expanders* local-macro-env t nil))
  290.  
  291. (defun compiler-macroexpand-1-w (form &optional local-macro-env)
  292.   (expand-macro form *compiler-macro-expanders* local-macro-env nil nil))
  293.  
  294. (defun expand-macro (form table menv
  295.               repeat? original-call-is-a-macro?)
  296.   (if (atom form)
  297.       (let ((def (lookup-symbol-macro-def form menv)))
  298.     (if (null def)
  299.         (values form original-call-is-a-macro?)
  300.         (values (second def) t)))
  301.       (if (atom (car form))
  302.       (let ((expander (lookup-macro-expander (car form)
  303.                          table
  304.                          menv)))
  305.         (if (null expander)
  306.         (values form original-call-is-a-macro?)
  307.         (let ((exp (funcall *macroexpand-hook-w*
  308.                     (basic-macro-expansion-function expander)
  309.                     form
  310.                     menv)))
  311.           (if (and repeat? (not (eq form exp)))
  312.               (expand-macro exp table menv repeat? t)
  313.               (values exp t)))))
  314.       (values form original-call-is-a-macro?))))
  315.  
  316. (defun lookup-macro-expander (name table menv)
  317.   (let ((local (and (not (null menv))
  318.             (assoc name (macro-env-macros menv) :test #'eq))))
  319.     (if (null local)
  320.     (gethash name table)
  321.     (cdr local))))
  322.  
  323. (defun lookup-symbol-macro-def (name menv)
  324.   (and (not (null menv))
  325.        (assoc name (macro-env-symbol-macros menv) :test #'eq)))
  326.  
  327. (defun remove-macro-expander (name)
  328.   (remhash name *macro-expanders*))
  329.  
  330. (defun remove-compiler-macro-expander (name)
  331.   (remhash name *compiler-macro-expanders*))
  332.  
  333. (defun remove-type-macro-expander (name)
  334.   (remhash name *type-macro-expanders*))
  335.  
  336. (defun parse-in/out (spec)
  337.   (multiple-value-bind (i o)
  338.       (if (member '=> spec :test #'eq)
  339.       (values (subseq spec 0 (position '=> spec))
  340.           (subseq spec (1+ (position '=> spec))))
  341.       (values spec nil))
  342.     (values (mapcar #'first i)
  343.         (mapcar #'first o)
  344.         (mapcar #'second i)
  345.         (mapcar #'second o))))
  346.  
  347. (defun quoted-constant-p (l)
  348.   (and (listp l)
  349.        (eq (first l) 'quote)
  350.        (null (cddr  l))))
  351.  
  352. (deftype lambda-expr ()
  353.   '(satisfies lambda-expr?))
  354.  
  355. ;;; Condition system thing.
  356. (defmacro with-keyword-pairs ((names expression &optional keywords-var)
  357.                   &body forms)
  358.   (let ((temp (member '&rest names)))
  359.     (unless (= (length temp) 2)
  360.       (error "&REST keyword is ~:[missing~;misplaced~]." temp))
  361.     (let ((key-vars (ldiff names temp))
  362.       (key-var (or keywords-var (gensym)))
  363.       (rest-var (cadr temp)))
  364.       (let ((keywords (mapcar #'(lambda (x)
  365.                   (intern (string x)
  366.                       *keyword-package*))
  367.                   key-vars)))
  368.     `(multiple-value-bind (,key-var ,rest-var)
  369.       (parse-keyword-pairs ,expression ',keywords)
  370.       (let ,(mapcar #'(lambda (var keyword)
  371.                 `(,var (getf ,key-var ,keyword)))
  372.             key-vars keywords)
  373.         ,@forms))))))
  374.